home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / scexpand.sc < prev    next >
Text File  |  1991-10-11  |  4KB  |  83 lines
  1. ;;; Macro expansion is done by this module.  It is based upon the ideas in
  2. ;;; "Expansion-Passing Style: Beyond Conventional Macros", 1986 ACM Conference
  3. ;;; on Lisp and Functional Programming.
  4.  
  5. ;*              Copyright 1989 Digital Equipment Corporation
  6. ;*                         All Rights Reserved
  7. ;*
  8. ;* Permission to use, copy, and modify this software and its documentation is
  9. ;* hereby granted only under the following terms and conditions.  Both the
  10. ;* above copyright notice and this permission notice must appear in all copies
  11. ;* of the software, derivative works or modified versions, and any portions
  12. ;* thereof, and both notices must appear in supporting documentation.
  13. ;*
  14. ;* Users of this software agree to the terms and conditions set forth herein,
  15. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  16. ;* right and license under any changes, enhancements or extensions made to the
  17. ;* core functions of the software, including but not limited to those affording
  18. ;* compatibility with other hardware or software environments, but excluding
  19. ;* applications which incorporate this software.  Users further agree to use
  20. ;* their best efforts to return to Digital any such changes, enhancements or
  21. ;* extensions that they make and inform Digital of noteworthy uses of this
  22. ;* software.  Correspondence should be provided to Digital at:
  23. ;* 
  24. ;*                       Director of Licensing
  25. ;*                       Western Research Laboratory
  26. ;*                       Digital Equipment Corporation
  27. ;*                       100 Hamilton Avenue
  28. ;*                       Palo Alto, California  94301  
  29. ;* 
  30. ;* This software may be distributed (but not offered for sale or transferred
  31. ;* for compensation) to third parties, provided such third parties agree to
  32. ;* abide by the terms and conditions of this notice.  
  33. ;* 
  34. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  35. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  36. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  37. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  38. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  39. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  40. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  41. ;* SOFTWARE.
  42.  
  43. (module scexpand)
  44.  
  45. (include "repdef.sc")
  46.  
  47. (define (EXPAND x) (initial-expander x initial-expander))
  48.  
  49. (define (INITIAL-EXPANDER x e)
  50.     (let ((e1 (cond ((symbol? x) *identifier-expander*)
  51.             ((not (pair? x)) (lambda (x e) x))
  52.             ((procedure? (expander? (car x))) (expander (car x)))
  53.             (else *application-expander*))))
  54.      (e1 x e)))
  55.  
  56. (define (EXPAND-ONCE x) (initial-expander x (lambda (x e) x)))
  57.  
  58. (define (*IDENTIFIER-EXPANDER* x e)
  59.     (let ((constant (expander x)))
  60.          (if (pair? constant) (car constant) x)))
  61.  
  62. (define (*APPLICATION-EXPANDER* x e) (map (lambda (x) (e x e)) x))
  63.  
  64. (define (INSTALL-EXPANDER keyword function)
  65.     (putprop keyword '*expander* function)
  66.     keyword)
  67.  
  68. (define (EXPANDER? x)
  69.     (and (symbol? x) (getprop x '*expander*)))
  70.  
  71. (define (EXPANDER x)
  72.     (getprop x '*expander*))
  73.  
  74. ;;; The following function tests an expression to verify that it is a list
  75. ;;; of a certain minimum length.  Optionally a maximum length will also be
  76. ;;; checked.
  77.  
  78. (define (ISLIST l min . max)
  79.     (do ((len 0 (+ len 1))
  80.      (l l (cdr l)))
  81.     ((not (pair? l))
  82.      (and (null? l) (>= len min) (or (null? max) (<= len (car max)))))))
  83.